;;;; -*- Mode: Lisp; Package: dreaming-tree; -*-

(in-package :dreaming-tree)

;;; Abstract Scene Renderer ;;;

(defparameter *current-key-event* nil)

(defmethod prepare-opengl :before ((r renderer))
  (determine-capabilities r)
  (with-slots (scene culler) r
    (when (and (slot-boundp r 'scene) scene)
      (log5:log-for (log5:renderer) "Initializing scene data ~A." scene)
      (initialize-data scene r))))

(defmethod initialize-data ((scene scene-manager) r)
  (initialize-data (scene-root scene) r))

(defmethod initialize-data ((scene list) r)
  (dolist (s scene)
    (initialize-data s r)))

(defmethod determine-capabilities ((canvas renderer))
  "Check for and enable various OpenGL extensions."
  (with-slots (gl-version-string gl-major-version gl-minor-version
				 vendor renderer extensions) canvas
    ;; Determine version
    (setf gl-version-string (gl:get-string :version))
    (let ((vers (cl-ppcre:split "\\." gl-version-string)))
      (setf gl-minor-version 0)
      (ignore-errors
	(setf gl-major-version (parse-integer (first vers))
	      gl-minor-version (parse-integer (second vers)))))
    ;; Determine extensions and vendor.
    (setf extensions (cl-ppcre:split "\\s+" (gl:get-string :extensions)))
    (setf vendor (gl:get-string :vendor))
    (setf renderer (gl:get-string :renderer))
    (log5:log-for (log5:renderer) "Detected GL version ~d.~d" gl-major-version gl-minor-version)))

;;;; Shader Programs

(defun %compile-shader (id shader)
  (gl:shader-source id (lib.gl::shader-source-code shader))
  (gl:compile-shader id)
  (unless (gl:get-shader id :compile-status)
    (error "Error compiling vertex shader: ~A~%~A" (gl:get-shader-info-log id) (shader-source-code shader))))

(defstruct shader-program
  id
  attributes
  uniforms)

(defun ensure-compiled-shaders (renderer named)
  (with-slots (compiled-shaders) renderer
    (let ((vshader (lib.gl:get-vertex-shader named))
	  (fshader (lib.gl:get-fragment-shader named)))
      (unless (gethash vshader compiled-shaders)
	(setf (gethash vshader compiled-shaders) (gl:create-shader :vertex-shader)))
      (unless (gethash fshader compiled-shaders)
	(setf (gethash fshader compiled-shaders) (gl:create-shader :fragment-shader)))
  ;; Compile the vertex program and check for errors
      (%compile-shader (gethash vshader compiled-shaders) vshader)
      (%compile-shader (gethash fshader compiled-shaders) fshader)
      (values (gethash vshader compiled-shaders) (gethash fshader compiled-shaders)))))

(defmethod compile-and-link-shader ((r renderer) shader-name)
  "Compile and link vertex and fragment shader code identified by shader-name. Shader-name refers to shader-source structures defined by defshader. Returns shader program id (as generated by GL) and creates a new shader-program structure in the *linked-programs* database."
  ;; Do something to ensure the gl context is active.
  (with-slots (linked-shaders) r
    (let ((program (gethash shader-name linked-shaders)))
      (multiple-value-bind (vid fid) (ensure-compiled-shaders r shader-name)
	(unless program
	  (setf program (setf (gethash shader-name linked-shaders) (make-shader-program
								    :id (gl:create-program)))))
	(gl:attach-shader (shader-program-id program) vid)
	(gl:attach-shader (shader-program-id program) fid)
      ;; Handle attributes
	(let ((attribs (remove-if #'(lambda (x)
				      (not (member (shader-attribute-type x) '(:in :attribute))))
				  (shader-source-attributes (get-vertex-shader shader-name))))
	      (idx 0))
	  (mapcar #'(lambda (a)
		      (gl:bind-attrib-location (shader-program-id program)
					       idx
					       (lib.gl::to-camel-case (shader-attribute-name a)))
		      (setf (shader-attribute-location a) idx)
		      (incf idx)
		      (push a (shader-program-attributes program)))
		  attribs))
	(gl:link-program (shader-program-id program))
      ;; Handle uniforms
	(let ((uniforms (remove-if #'(lambda (x)
				       (not (member (shader-attribute-type x) '(:uniform))))
				   (shader-source-attributes (get-vertex-shader shader-name)))))
	  (mapcar #'(lambda (u)
		      (setf (shader-attribute-location u) (gl:get-uniform-location (shader-program-id program)
										   (lib.gl::to-camel-case (shader-attribute-name u))))
		      (push u (shader-program-uniforms program)))
		  uniforms))
	(unless (gl:get-program (shader-program-id program) :link-status)
	  (error "Error linking program: ~A" (gl:get-program-info-log (shader-program-id program))))
	program))))

(defun compile-and-link-all-shaders (r)
  (iter (for (k v) in-hashtable lib.gl::*defined-vshaders*) ; Hack
        (compile-and-link-shader r k)))


(defun use-shader (shader &key uniforms attributes)
  (multiple-value-bind (sprog foundp) (gethash shader *linked-programs*)
    (when (not foundp)
      (warn "Shader program ~A does not exist, or has not been compiled and linked, so I am trying to do that right now." shader)
      (setq sprog (compile-and-link-shader shader))
)
    (gl:use-program (shader-program-id sprog))
    ;; Set up uniforms
    (if (> (length (shader-program-uniforms sprog)) (length uniforms))
        (error "Shader program ~A needs at least ~A uniform arguments, only ~A provided." 
               shader 
               (length (shader-program-uniforms sprog))
               (length uniforms)))
    (dolist (u (shader-program-uniforms sprog))
      (let* ((uloc (shader-attribute-location u))
             (utyp (shader-attribute-storage u))
             (udat (elt uniforms uloc)))
        (case utyp
          ((vec2 vec3 vec4) (gl:uniformfv uloc udat))
          (int (gl:uniformi uloc udat))
          (float (gl:uniformf uloc udat))
          (mat2 (gl:uniform-matrix uloc 2 udat)) 
          (mat3 (gl:uniform-matrix uloc 3 udat)) 
          (mat4 (gl:uniform-matrix uloc 4 udat)))))
    ;; Set up attributes
    ))

;;; More shameless borrowing from XMLisp
(defmethod delta-time ((self renderer)) 
  "Return time in seconds passed since last animation."
  #+X8632-target (declare (optimize (safety 2))) ;; avoid 2^32 nano second time warps in CCL 32bit
  #+darwin-target
  (let ((Time (#_mach_absolute_time)))
    (prog1
        (if (zerop (current-time Self))
          0.0                           ;First time through
          (float (* 0.000000001
                    (- Time (current-time Self))
                    #.(ccl::rlet ((info #>mach_timebase_info))
                        (#_mach_timebase_info info)
                        (/ (ccl::pref info #>mach_timebase_info.numer)
                           (ccl::pref info #>mach_timebase_info.denom))))))
      (setf (current-time Self) Time)))
  #+windows-target
  (let ((Time (ccl:rlet ((now #>FILETIME))
		(#_GetSystemTimeAsFileTime now)
		(dpb (ccl:pref now #>FILETIME.dwHighDateTime)
		     (byte 32 32)
		     (ccl:pref now #>FILETIME.dwLowDateTime)))))
    (prog1
     (if (zerop (current-time Self))
	 0.0				;First time through
	 (float (* 0.0000001 (- Time (current-time Self)))))
     (setf (current-time Self) Time)))
  #+linux-target
  (multiple-value-bind (curr dt) (hardware-delta-time)
    (setf (current-time self) curr)
    dt))


#+linux-target
(defun hardware-timer-resolution ()
    (ccl:rlet ((tv :timespec))
      (#_clock_getres #$CLOCK_MONOTONIC tv)
      (+ (ccl:pref tv :timespec.tv_sec) (* (ccl:pref tv :timespec.tv_nsec) 1e-9))))

#+linux-target
(defparameter *timer-resolution* #.(hardware-timer-resolution))

#+linux-target
(let ((hardware-current-time 0.0))
  (defun hardware-current-time ()
    hardware-current-time)
  (defun hardware-delta-time () 
    #+:X8632-target (declare (optimize (safety 2))) ;; avoid 2^32 nano second time warps in CCL 32bit
    (let ((now (ccl:rlet ((tv :timespec))
		 (#_clock_gettime #$CLOCK_MONOTONIC tv)
		 (+ (ccl:pref tv :timespec.tv_sec)
		    (* 1e-9 (ccl:pref tv :timespec.tv_nsec))))))
      (format t "~A  ~A~%" now *timer-resolution*)
      (values 
       (if (= hardware-current-time 0.0)
	   0.0
	   (/ (- now hardware-current-time) *timer-resolution*))
       (setf hardware-current-time now)))))

(defmethod xml:add-subobject ((r renderer) (s spatial))
  (setf (insert-object (renderer-scene r)) s)
  (setf (view s) r))

(defmethod print-slots ((r renderer))
  '(scene-root gl-version-string type-safety-p))


;;; Basic Motion

(defmethod move-forward ((view scene-manager) &optional (move-speed 0.1))
  (with-slots (camera world-axis free-camera-move-p) view
    (with-slots (eye) camera
      (if free-camera-move-p
	  (setf eye (m+ eye (m* move-speed (camera-d camera))))
	  (setf eye (m+ eye (m* move-speed (get-column world-axis 0))))))))

(defmethod move-back ((view scene-manager) &optional (move-speed 0.1))
  (with-slots (camera world-axis free-camera-move-p) view
    (with-slots (eye) camera
      (if free-camera-move-p
	  (setf eye (m- eye (m* move-speed (camera-d camera))))
	  (setf eye (m- eye (m* move-speed (get-column world-axis 0))))))))

(defmethod pan-right ((view scene-manager) &optional (move-speed 0.1))
  (with-slots (camera world-axis free-camera-move-p) view
    (with-slots (eye) camera
      (if free-camera-move-p
	  (setf eye (m+ eye (m* move-speed (camera-r camera))))
	  (setf eye (m+ eye (m* move-speed (get-column world-axis 2))))))))

(defmethod pan-left ((view scene-manager) &optional (move-speed 0.1))
  (with-slots (camera world-axis free-camera-move-p) view
    (with-slots (eye) camera
      (if free-camera-move-p
	  (setf eye (m- eye (m* move-speed (camera-r camera))))
	  (Setf eye (m- eye (m* move-speed (get-column world-axis 2))))))))

(defmethod pan-up ((view scene-manager) &optional (move-speed 0.1))
  (with-slots (camera world-axis free-camera-move-p) view
    (with-slots (eye) camera
      (if free-camera-move-p
	  (setf eye (m+ eye (m* move-speed (camera-u camera))))
	  (setf eye (m+ eye (m* move-speed (get-column world-axis 1))))))))

(defmethod pan-down ((view scene-manager) &optional (move-speed 0.1))
  (with-slots (camera world-axis free-camera-move-p) view
    (with-slots (eye) camera
      (if free-camera-move-p
	  (setf eye (m- eye (m* move-speed (camera-u camera))))
	  (setf eye (m- eye (m* move-speed (get-column world-axis 1))))))))

(defun to-unit-sphere (radius point &optional (origin #(0.0 0.0 0.0)))
  (let* ((x (/ (- (x point) (x origin) radius)))
	 (y (/ (- (- (y point) (y origin) radius))))
	 (modulus (+ (* x x) (* y y)))
	 (z (sqrt (- 1 modulus))))
    (when (> modulus 1.0)
      (warn "Point ~A is somehow outside of the sphere centered at ~A with radius ~A.  Go figure." point origin radius))
    (vector x y z)))

(defparameter *base-turn-speed* 0.01)

(defmethod turn-left ((view renderer) &optional (move-speed *base-turn-speed*))
  (with-slots (camera world-axis free-camera-move-p) view
    (with-slots (r u d) camera
      (let ((rotincr (matrix-from-axis-angle (if free-camera-move-p
						 u
						 (get-column world-axis 1))
					     move-speed)))
	(unless free-camera-move-p
	  (set-column world-axis 0 (m* rotincr (get-column world-axis 0)))
	  (set-column world-axis 1 (m* rotincr (get-column world-axis 1))))
	(setf r (m* rotincr r)
	      d (m* rotincr d)
	      u (m* rotincr u))))))

(defmethod turn-right ((view renderer) &optional (move-speed *base-turn-speed*))
  (with-slots (camera world-axis free-camera-move-p) view
    (with-slots (r u d) camera
      (let ((rotincr (matrix-from-axis-angle (if free-camera-move-p
						 u
						 (get-column world-axis 1))
					     (- move-speed))))
	(unless free-camera-move-p
	  (set-column world-axis 0 (m* rotincr (get-column world-axis 0)))
	  (set-column world-axis 1 (m* rotincr (get-column world-axis 1))))
	(setf r (m* rotincr r)
	      d (m* rotincr d)
	      u (m* rotincr u))))))

(defmethod look-up ((view renderer) &optional (move-speed *base-turn-speed*))
  (with-slots (camera world-axis free-camera-move-p) view
    (with-slots (r u d) camera
      (let ((rotincr (matrix-from-axis-angle (if free-camera-move-p
						 r
						 (get-column world-axis 2))
					     move-speed)))
	(setf r (m* rotincr r)
	      d (m* rotincr d)
	      u (m* rotincr u))))))

(defmethod look-down ((view renderer) &optional (move-speed *base-turn-speed*))
  (with-slots (camera world-axis free-camera-move-p) view
    (with-slots (r u d) camera
      (let ((rotincr (matrix-from-axis-angle (if free-camera-move-p
						 r
						 (get-column world-axis 2))
					     (- move-speed))))
	(setf r (m* rotincr r)
	      d (m* rotincr d)
	      u (m* rotincr u))))))
  

(defmethod turn ((view renderer) dx dy &optional (move-speed 1)) ; Smaller values mean faster movement here.
  (with-slots (camera width height) view
    (setf (culler-update-p view) t)
    (cond ((plusp dx) (turn-right view))
	  ((minusp dx) (turn-left view)))
    (cond ((plusp dy) (look-up view))
	  ((minusp dy) (look-down view)))))

(defmethod pan-camera ((view scene-manager) dx dy &optional (move-speed 0.1)) ; Smaller values mean faster movement here.
  (with-slots (camera) view
    (cond ((plusp dx) (pan-right view move-speed))
	  ((minusp dx) (pan-left view move-speed)))
    (cond ((plusp dy) (pan-up view move-speed))
	  ((minusp dy) (pan-down view move-speed)))))

(defmethod controller-update ((canvas renderer))
  "Update all the controllers in the scene graph, this is sort of a physics/game logic update."
  (with-slots (current-time current-timestep scene) canvas
    (labels ((spatial/controller-update (spatial)
	       (update-controllers (controllers spatial) spatial current-timestep current-time))
	     (node/controller-update (node)
	       (with-slots (controllers children) node
		 (when controllers
		   (update-controllers controllers node current-timestep current-time))
		 (when children
		   (dolist (c children)
		     (case (type-of c) 
		       (node (node/controller-update c))
		       (t (spatial/controller-update c))))))))
      (dolist (obj scene)
	(if (eql (type-of obj) 'node)
	    (node/controller-update obj)
	    (spatial/controller-update obj))))))

(defmethod on-idle ((canvas renderer))
  (with-slots (culler culler-update-p object-moved-p scene-root) canvas
    ;; Logic for geometry and renderer updates necessary?
    (move-camera canvas) ; Why not do this as part of event polling?
    (draw-scene canvas (determine-visible-set culler scene-root))))

(defparameter *current-pick-ray* nil)

(defmethod generate-pick-ray ((canvas renderer) x y)
  (with-slots ((sw screen-width) (sh screen-height) scene) canvas
    (with-slots (camera) scene
      (multiple-value-bind (umin umax rmin rmax) (frustum-coordinates camera)
	(let* ((xp (/ x sw))
	       (yp (- 1 (/ y sh)))
	       (xv (+ (* rmin (- 1 xp)) (* xp rmax)))
	       (yv (+ (* umin (- 1 yp)) (* yp umax)))
	       (n (distance (camera-eye camera) (near-plane camera)))
	       (w (m/ (m+ (m* n (camera-d camera))
			  (m* xv (camera-r camera))
			  (m* yv (camera-u camera)))
		      (+ (* n n) (* xv xv) (* yv yv)))))
	  (format t "Pick ray originating from eye ~A to screen pixel ~A~%" (camera-eye camera) (list x y))
	  (format t "Converted to near plane coordinates ~A~%" (list xv yv))
	  (format t "Converted to pick ray with direction ~A.~%" w)
	  (setf *current-pick-ray* (make-instance 'ray :point (camera-eye camera)
						  :direction w)))))))

;;; A few helper functions for creating sample scenes

(defun cube-scene ()
  (let ((n (make-node :named "Root"))
	(c1 (new-box #(0.0 0.0 0.0)))
	(c2 (new-box #(0.0 8.0 0.0)))
	(c3 (new-box #( 0.0 -8.0 0.0))))
    (attach c1 n)
    (attach c2 n)
    (attach c3 n)
    n))

(defun physics-scene ()
  (let ((n (make-node :named "Scene Root"))
	(pn (make-node :named "Physcis Objects"))
	(o1 (make-marble 1.0 1.0 #(2.0 10.0 0.0) #(0.0 1.0 0.0)))
	(o2 (make-marble 1.0 1.0 #(-2.0 10.0 0.0) #(0.0 1.0 1.0)))
	(o3 (make-marble 1.0 0.5 #(-4.0 0.0 0.0) #(0.8 0.3 0.8)))
	(c4 (make-cube 10.0 10.0 0.0 :scale-x 0.1 :scale-y 0.1 :scale-z 0.1 :color #(0.0 0.0 0.0)))
	(scn1 (cube-scene))
	(g1 (make-instance 'gravity :acceleration #(0.0 -0.01 0.0)))
	(g2 (make-instance 'gravity :acceleration #(0.0 -0.05 0.0))))
    (pushnew g1 (force o1))
    (pushnew g2 (force o2))
    (attach (make-instance 'move-to-control :k 0.1) o3)
    (attach o1 pn)
    (attach o2 pn)
    (attach o3 pn)
    (attach c4 scn1)
    (attach scn1 n)
    (attach pn n)
    n))

(defun sphere-scene ()
  (let* ((n (make-node :named "Root"))
	 (mc (make-instance 'mesh-constructor))
	 (c1 (standard-sphere-mesh mc 20 20 1.0))
	 (c2 (standard-sphere-mesh mc 20 20 4.0))
	 (c3 (standard-sphere-mesh mc 20 20 2.5)))
    (attach c1 n)
    (attach c2 n)
    (attach c3 n)
    n))
  
(defun spinning-cube-scene ()
  (let ((n (make-node :named "Root"))
	(c1 (make-cube 0.0 0.0 0.0))
	(c2 (make-cube 0.0 4.0 0.0))
	(c3 (make-cube 0.0 -4.0 0.0))
	(s (make-instance 'spin-controller :spin-rate-x 0.1 :spin-rate-y 0.05 :spin-rate-z 0.01)))
    (attach c1 n)
    (attach s c1)
    (attach c2 n)
    (attach c3 n)
    n))

(defun cube-o-rama ()
  (let ((n (make-node :named "SceneRoot")))
    (dotimes (i 10 n)
      (dotimes (j 10)
	(attach (make-cube (- (* i 4.0) 20.0) (- (* j 4.0) 20.0) 0.0
			   :color (vector (random 1.0) (random 1.0) (random 1.0)))
		n)))))

(defun cube-mega-rama ()
  (let ((n (make-node :named "SceneRoot")))
    (dotimes (i 100 n)
      (dotimes (j 100)
	(attach (new-box (vector (- (* i 4.0) 200.0) (- (* j 4.0) 200.0) 0.0) :color #(1.0 0.0 0.0))
		n)))))
  
(defun spinning-cube-o-rama ()
  (let ((scene (cube-o-rama))
	(spinner (make-instance 'spin-controller :spin-rate-x 0.01 :spin-rate-y 0.01)))
    (dolist (c (children scene) scene)
      (attach spinner c))))

(defun spinning-cube-mega-rama ()
  ;; On your knees, worm!
  (let ((scene (cube-mega-rama))
	(spinner (make-instance 'spin-controller :spin-rate-x 0.01 :spin-rate-y 0.01)))
    (dolist (c (children scene) scene)
      (attach spinner c))))

(defun fast-cube ()
  (let ((n (make-node :named "SceneRoot")))
    (attach (make-simple-cube) n)
    n))

(defun vbo-test ()
  (test-scene (fast-cube)))
    

;;;; Debugging distance and which-side functions

(defun plane-distance-scene ()
  (let* ((root (make-node :named "Root"))
	 (mc (make-instance 'mesh-constructor :normals-p t))
	 (plane (rectangle 2 2 10.0 10.0))
	 (point (standard-sphere-mesh 20 20 1.0)))
    (attach plane root)
    (attach point root)
    (move-to point 0.0 5.0 0.0)
    (rotate-by plane :rx 90.0 :radians nil)
    (move-to plane 0.0 -5.0 0.0)
    root))
    
